Delphi Informant Complete 1995 - 2000/Delphi Informant Complete 1995 to 2000.iso/Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar/1998/Jul/di9807rl/gradient.pas

Pascal/Delphi Source File | 1998-02-24 | 8KB | 283 lines

unit Gradient;

{ Demostration of palettes in a Delphi component.
  Copyright ⌐ 1998 Tempest Software, Inc.

  The TGradient component displays a color gradient, with
  a user-specified starting and ending color, and number of
  color steps between them.
}

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, ExtCtrls;

type
  TGradientOrientation = (goVertical, goHorizontal);
  TNumColors = 1..255;
  TGradient = class(TGraphicControl)
  private
    // Colors for the end pointers in the gradient
    fColorTop, fColorBottom: TColor;
    // Number of steps in the gradient
    fNumColors: TNumColors;
    // Horizontal or vertical gradient
    fOrientation: TGradientOrientation;

    // Palette information
    fPalette: HPalette;           // handle to the palette
    fLogPalette: PLogPalette;     // pointer to logical palette

    procedure SetColorTop(Value: TColor);
    procedure SetColorBottom(Value: TColor);
    procedure SetNumColors(Value: TNumColors);
    procedure SetOrientation(Value: TGradientOrientation);
    procedure WmEraseBkgnd(var Msg: TWmEraseBkgnd); message Wm_EraseBkgnd;
  protected
    procedure AllocatePalette(NumColors: Integer); virtual;
    procedure DestroyPalette; virtual;
    procedure GetColor(var Red, Green, Blue: Byte; Index: Integer); virtual;
    function GetPalette: HPalette; override;
    function MakePalette: HPalette; virtual;
    procedure Paint; override;
    property Palette: HPalette read fPalette;
    property LogPalette: PLogPalette read fLogPalette;
  public
    constructor Create(Owner: TComponent); override;
    destructor Destroy; override;
  published
    property Align;
    property DragCursor;
    property DragMode;
    property Height default 100;
    property Visible;
    property Width default 100;
    property OnDblClick;
    property OnDragOver;
    property OnDragDrop;
    property OnEndDrag;
    property OnMouseMove;
    property OnMouseDown;
    property OnMouseUp;
    property OnClick;
    property OnStartDrag;
    property ColorTop: TColor read fColorTop write SetColorTop default clBlue;
    property ColorBottom: TColor read fColorBottom write SetColorBottom default clBlack;
    property NumColors: TNumColors read fNumColors write SetNumColors default 64;
    property Orientation: TGradientOrientation read fOrientation write SetOrientation;
  end;

procedure Register;

implementation

// Create and initialize the control. Start with 64 steps
// because most palette devices use 18 bits per pixel,
// which means 6 bits per color, or 64 distinct colors.
// The colors blue and black look nice, but feel free to
// change them to whatever you find more aesthetic.
// Ditto for the default size.
constructor TGradient.Create(Owner: TComponent);
begin
  inherited Create(Owner);

  fColorTop := clBlue;
  fColorBottom := clBlack;
  fNumColors := 64;

  Height := 100;
  Width := 100;
end;

// Destroy the control.
// Clean up by freeing the palette resource and memory.
destructor TGradient.Destroy;
begin
  DestroyPalette;
  inherited Destroy;
end;

// Calculate a color at position Index in the gradient, and set
// the Red, Green, and Blue arguments to the color's elements.
procedure TGradient.GetColor(var Red, Green, Blue: Byte; Index: Integer);
var
  Top, Bottom: TColor;
  NumColors: Integer;
begin
  Top := ColorToRgb(ColorTop);
  Bottom := ColorToRgb(ColorBottom);
  NumColors := LogPalette.palNumEntries;

  Red :=
    MulDiv(NumColors-Index-1, GetRValue(Top), NumColors-1) +
    MulDiv(Index, GetRValue(Bottom), NumColors-1);

  Green :=
    MulDiv(NumColors-Index-1, GetGValue(Top), NumColors-1) +
    MulDiv(Index, GetGValue(Bottom), NumColors-1);

  Blue :=
    MulDiv(NumColors-Index-1, GetBValue(Top), NumColors-1) +
    MulDiv(Index, GetBValue(Bottom), NumColors-1);
end;

// Allocate the logical palette record so it is large enough
// for NumColors palette entries. The caller must already have
// destroyed the old palette. After calling AllocatePalette,
// the caller must initialize the palette entries.
procedure TGradient.AllocatePalette(NumColors: Integer);
begin
  Assert(LogPalette = nil);

  // TLogPalette already has one palette entry, so we need NumColors-1 more.
  GetMem(fLogPalette, SizeOf(TLogPalette) + (NumColors-1)*SizeOf(TPaletteEntry));
  LogPalette.palVersion := $300;
  LogPalette.palNumEntries := NumColors;
end;

// Make a gradient palette and return the palette handle.
// Call this once when initializing the control.
// If the user changes the number of steps or the colors,
// recreate the palette with the new information.
function TGradient.MakePalette: HPalette;
var
  I: Integer;
begin
  AllocatePalette(NumColors);

  {$R- Turn off range checking to access palette entries.}
  for I := 0 to LogPalette.palNumEntries-1 do
    with LogPalette.palPalEntry[I] do
    begin
      GetColor(peRed, peGreen, peBlue, I);
      peFlags := 0
    end;
  {$R+}

  Result := CreatePalette(LogPalette^);
end;

// Destroy the palette and free the palette memory.
procedure TGradient.DestroyPalette;
begin
  if Palette <> 0 then
  begin
    DeleteObject(Palette);
    fPalette := 0;
  end;
  FreeMem(LogPalette);
  fLogPalette := nil;
end;

// Change the top color.
procedure TGradient.SetColorTop(Value: TColor);
begin
  if Value <> ColorTop then
  begin
    fColorTop := Value;
    DestroyPalette;
    Invalidate;
  end;
end;

// Change the bottom color.
procedure TGradient.SetColorBottom(Value: TColor);
begin
  if Value <> ColorBottom then
  begin
    fColorBottom := Value;
    DestroyPalette;
    Invalidate;
  end;
end;

// Change the direction of the gradient.
procedure TGradient.SetOrientation(Value: TGradientOrientation);
begin
  if Value <> Orientation then
  begin
    fOrientation := Value;
    Invalidate;
  end;
end;

// Change the number of steps in the gradient. Note that
// this requires rebuilding the palette with a new size.
procedure TGradient.SetNumColors(Value: TNumColors);
begin
  if Value <> NumColors then
  begin
    fNumColors := Value;
    DestroyPalette;
    Invalidate;
  end;
end;

// Return the palette handle, building the palette if necessary.
function TGradient.GetPalette: HPalette;
begin
  if Palette = 0 then
    fPalette := MakePalette;
  Result := Palette;
end;

// Paint the gradient. Tell Windows to use the palette when
// painting this control. To do this, explicitly select
// the palette and use PaletteIndex as the color.
//
// To paint the gradient, divide the canvas into NumColors bands,
// and fill each band with a solid color, chosen from the palette.
procedure TGradient.Paint;
var
  I: Integer;
  X, Y: Integer;       // current position on canvas
  Rect: TRect;         // rectangle for filling one band in the gradient
  OldPal: HPalette;    // old palette
  Red, Green, Blue: Byte;
begin
  Rect := ClientRect;
  Y := 0;
  X := 0;
  OldPal := SelectPalette(Canvas.Handle, GetPalette, False);
  try
    for I := 0 to NumColors-1 do
    begin
      {$R-}
      with LogPalette.palPalEntry[I] do
        Canvas.Brush.Color := PaletteRgb(peRed, peGreen, peBlue);
      {$R+}
      if Orientation = goVertical then
      begin
        Rect.Top := Y;
        Y := MulDiv(ClientHeight, I + 1, NumColors);
        Rect.Bottom := Y;
      end
      else
      begin
        Rect.Left := X;
        X := MulDiv(ClientWidth, I + 1, NumColors);
        Rect.Right := X;
      end;
      Canvas.FillRect(Rect);
    end;
  finally
    SelectPalette(Canvas.Handle, OldPal, False);
  end;
end;

// Do not erase the background because the Paint method repaints
// the entire client area. This reduces flicker.
procedure TGradient.WmEraseBkgnd(var Msg: TWmEraseBkgnd);
begin
  Msg.Result := 1;
end;


procedure Register;
begin
  RegisterComponents('Tempest', [TGradient]);
end;

end.